perm filename TREST.OLD[MSS,LCS]4 blob
sn#107259 filedate 1974-10-23 generic text, type T, neo UTF8
00100 C******* SUBRS TAIL, FERMTA, REST, RDDATA, BREP, EXCH, SORT2, NOZERO, ALPHA
00200 SUBROUTINE TAIL(RJX,RA,RMINI)
00300 COMMON /STF/RSTFAC(8),RSTJC
00400 COMMON /PLTR/IPLT,RHT,DIS
00500 DIMENSION ITAIL(16)
00600 DATA ITAIL/16,100090007,110012,120016,200120016,120019,100026,
00700 1 80030,20036, 40, 33, 30031, 50029,80025,100022,120016/
00800 Q=-1.
00900 IF(RA)Q=1.
00910 ITAIL(1)=10
00955 IF(IPLT)ITAIL(1)=16
01000 CALL CENTER(RJY)
01100 CALL JDRAW(ITAIL,RJX,RJY,RMINI,1.,Q)
01200 1 IF(IPLT.GE.0)RETURN
01300 IF(RMINI.NE.RSTJC)Q=Q*.6
01400 CC CALL OLDFIL(ITAIL(10),RJX,RJY,ABS(Q),Q)
01500 CALL FILLMS(12,ITAIL(5),RJX,RJY,ABS(Q),Q)
01600 C RA=-,STEM UP; RA=+, STEM DOWN.
01700 END
01800
01900 SUBROUTINE REST
02000 COMMON /STF/RSTFAC(8),RSTJC/PLTR/IPLT,RHT,DIS
02100 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
02200 EQUIVALENCE(JE,JQ(3))
02300 DIMENSION LRST(3),IRST(47),MR(2),MF(2)
02400 DATA IRST/9,100000033,160033,160030, 30,32 ,160032 ,160031,
02600 1 31, 23,100000051,100038,32,110017,200050044, 32 ,50026,
02700 1 100038,50044,100110017,70018,50017,50015,60011, 10016,
02800 1 18, 20,10022,30023, 50023, 70022,110017,
02900 1 15,100030033, 40032, 80032,120035,150039,70014,200010037,
03000 1 30039, 50039, 70037, 70035, 50033, 30033,10035/
03100 1,LRST/1,10,33/,MR/18,8/,MF/15,40/
03150 C LRST = BEGINNING OF EACH REST, MR=FILLER WDCNT, MF=FILL START.
03200
03300 IF(LRST(1).EQ.0)CALL RDDATA('REST',LRST,IRST)
03400 L=JE
03500 IF(L.GT.1)L=1
03600 IF(L)L=-1
03700 C L>3 WHEN SEVERAL TAILS ON REST
03800 CALL CENTER(CENTR)
03900 IF(JE.EQ.-2)CENTR=CENTR+9.4*RSTJC
04000 CALL JDRAW(IRST(LRST(L+2)),RJB,CENTR,RSTJC,1.,1.)
04100 IF(JE.OR.IPLT.GE.0)RETURN
04200 L=L+1
04300 CALL FILLMS(MR(L),IRST(MF(L)),RJB,CENTR,1.,1.)
04400 C WHY GO THROUGH NOTWRT??
04500 END
04600
04700 SUBROUTINE RDDATA(NM,JARY,IARY)
04800 C READS DATA
04900 DIMENSION JARY(1),IARY(1)
05000 REWIND 23
05100 CALL IFILE(23,NM)
05200 READ(23,5)K,(JARY(K),K=1,10)
05300 N=1
05400 1 READ(23,5,END=2)K,L,(IARY(K),K=N,N+L-1)
05500 N=N+L
05600 GO TO 1
05700 2 RETURN
05800 5 FORMAT(12I)
05900 END
06000
06100 C FOR SINGLE (OR DOUBLE) BAR REPEAT SIGN
06200 SUBROUTINE BREP(RJB,RSTJC)
06300 DIMENSION IREP(35)
06400 DATA IREP/35,100000015,280043,290043, 10015, 20015, 300043,310043
06500 1,30015, 40015, 320043,100020037, 30038, 40038, 50037
06600 1,50036, 40035, 30035, 20036, 20037, 50037, 20036, 40036
06700 1,100270022,280021,290021,300022,300023,290024,280024,270023
06800 1,270022, 300022, 270023, 290023/
06900 CC IF(JREP(1).EQ.0)CALL RDDATA('BREP',JREP,IREP)
07000 CALL CENTER(R)
07100 CALL JDRAW(IREP,RJB,R,RSTJC,1.,1.)
07200 END
07300
07400 SUBROUTINE FERMTA(RINV)
07500 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
07600 COMMON /PLTR/IPLT,RHT,DIS
07700 COMMON /STF/RSTFAC(8),RSTJC
07800 DIMENSION JFERM(24)
07900 DATA JFERM/24,310020003,10010010,20015,60017,110017,160015,
08000 1 190010,200003,170010,150012,120014,70014,30012,10010,
08100 1 10020003,100070007,80008,100008,110007,110006,100005,80005
08200 1 ,70006/
08300 CC IF(JFERM(1).EQ.0)CALL RDDATA('FERM',JFERM,IFERM)
08400 CC R=INV
08500 CALL JDRAW(JFERM,RJB,CENTR,RSTJC,1.,RINV)
08600 CC IF(IPLT)CALL OLDFIL(IFERM(IFERM(1)+2),RJB,CENTR,1.,RINV)
08700 IF(IPLT)CALL FILLMS(JFERM(1),JFERM(2),RJB,CENTR,1.,RINV)
08800 END
08900
09000 SUBROUTINE EXCH(X,Y)
09100 Z=X
09200 X=Y
09300 Y=Z
09400 END
09500 SUBROUTINE SORT2(RPOS,M)
09600 DIMENSION RPOS(2,200)
09700 L=2
09800 3 J=-1
09900 RX=RPOS(1,L-1)
10000 DO 2 K=L,M
10100 IF(RPOS(1,K).GE.RX)GO TO 2
10200 RX=RPOS(1,K)
10300 C WHY WERE ALL THE RX'S JX ????? 9/6/73
10400 J=K
10500 2 CONTINUE
10600 IF(J)GO TO 4
10700 K=L-1
10800 CALL EXCH(RPOS(1,K),RPOS(1,J))
10900 CALL EXCH(RPOS(2,K),RPOS(2,J))
11000 4 L=L+1
11100 IF(L.LE.M)GO TO 3
11200 END
11300
11400 SUBROUTINE NOZERO(X)
11500 IF(X.EQ.0)X=1
11600 END
00100 C****** FOR LISTS OF LETTERS, ETC. *******
00200 SUBROUTINE ALPHA
00300 COMMON /PLTR/IPLT,RHT,DIS
00400 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00500 EQUIVALENCE(JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJE,RJQ(3)),
00600 1(RJH,RJQ(6)),(NRJ,RJQ(8)),(JY,JQ(10)),(JX,JQ(11)),(RSX,JQ(12)),
00700 1(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
00800 1,(JK,JQ(9)),(JF,JQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2)),(IFNT,JQ(13)),
00810 1(NR,JQ(14)),(RSP,JQ(15)),(RY,JQ(16)),(RX,JQ(17)),(RZ,JQ(18)),(RW
00820 1,JQ(19)),(RB,JQ(20)),(R,RJQ(20)),(FILL,RJQ(19)),
00830 1(JTR,RJQ(17)),(RTR,RJQ(16)),(RF,RJQ(15)),(JBX,RJQ(14))
00900 COMMON/STF/RSTFAC(8),RSTJC
01000 DATA RS/1.1/,R4/-2.1/,RSPC/.9/,JFIX/-1/
01100
01200 IF(JA.EQ.20)GO TO 20
01210 JTR=99
01400 C PRIMITIVE IS DEFAULT FONT. #=SET BACK TO PRIM.
01500 C ONLY 11 LETTERS WITHOUT FONT RESET.
01700 54 R=19.7*RJE*RSTJC
01800 RB=JB
02300 DO 50 KA=4,6
02400 JY=RJQ(KA)*100.+.2
02500 JX=1000000
02600 DO 53 LA=1,4
02700 JF=JY/JX
02800 IF(JF.EQ.47.OR.JF.GT.90)GO TO 2
02900 IF(JF.LT.47.AND.IFNT.EQ.0)GO TO 3
03000 C JUMP TO USE PRIMITIVE ALPHABET.
03200 IF((JF.GT.9.AND.JF.LT.36).OR.JF.GT.47)GO TO 10
03300 C NEXT FOR NUMBERS, SPACE AND PUNCTUATION.
03500 RSX=RSPC
03600 IF(JF.GT.9)GO TO 3
03700 GO TO 4
03800 10 IF(JF.LT.47)GO TO 5
03900 IF(JF.NE.48)GO TO 7
04000 IFNT=1
04100 C $=48=UPPER CASE
04300 GO TO 11
04400 7 IF(JF.NE.49)GO TO 8
04500 IFNT=-1
04600 C %=LOWER CASE
04800 GO TO 11
04900 8 IF(JF.NE.50)GO TO 13
05000 NR='BDR40'
05200 C &=NON-ITALICS -- JFIX IS TEMPORARY SWITCH 5/74
05300 13 IF(JF.NE.51)GO TO 14
05400 NR='BDI40'
05600 C @=51=ITALICS
05700 14 IF(JF.NE.52)GO TO 11
05800 IFNT=0
05900 C #=52=PRIMITIVE
06000 JA=5
06100 RSX=1.
06200 GO TO 11
06300 9 IF(JF.LT.52)GO TO 11
06400 IF(JF.EQ.53)FILL=-2
06500 IF(JF.EQ.54)FILL=0
06600 C < = 53 = NO FILL, > = 54 = FILL
06700 GO TO 11
06800 5 IF(IFNT)RSX=.8
06900 IF(JF.LE.9)RSX=RSPC
07000 IF(JF.EQ.22.OR.JF.EQ.32)RSX=RSX*1.1
07100 IF(JF.EQ.1.OR.JF.EQ.18.OR.JF.EQ.19.OR.(JF.EQ.21.AND.IFNT))
07200 1 RSX=RSX*.8
07300 4 IF(JFIX.AND.IPLT.GE.0)GO TO 3
07400 C JFIX=-1 FOR FIXED WIDTH OF FONTS. = AND ONLY DPYS PRIMITIVE.
07500 C******** SET JFIX TO -1 IN DDT TO USE FIXED WIDTH.
07600 JE=JF
07700 IF(IFNT.AND.JE.GT.9)JE=JE+26
07800 RX=RJF
07900 RJF=RJE*.28
08000 C .29 IS SIZE FACTOR -- PERHAPS CHANGE SIZE IN FONT TO =1.
08100 RY=RJG
08200 RJG=RJF
08300 RZ=RJH
08400 RW=RJD
08500 RJD=RJD+R4
08600 RJH=FILL
08700 NRJ=NR
08800 C GETS RIGHT FILE
08900 JA=11
09000 CC*** CALL NOTWRT
09025 RJB=JB
09050 CALL CLEFS
09100 RJF=RX
09200 RJG=RY
09300 RJH=RZ
09400 RJD=RW
09500 C PUTS BACK RIGHT STUFF
09600 IF(JFIX)GO TO 12
09700 GO TO 2
09800
09900 3 JA=5
09950 JG=0
10000 CALL NOTWRT
10100 C 47=BLANK (WAS 99)
10300 12 RSX=1.
10400 2 RB=RB+R*RSX
10500 JB=ROFF(RB)
11000 11 JY=JY-JF*JX
11100 RSX=RS
11200 53 JX=JX/100
11300 50 CONTINUE
11310 IF(JTR.EQ.99)RETURN
11400 GO TO 52
11500
11600 C FOR TRILLS
11700 20 RTR=RJB
11800 C RTR SAVES RJB(WHICH GETS CLOBBERED WHEN 'TR' IS WRITTEN.)
11900 C 20, POS1, STF, NT#, 0, POS2, X IF X=1 THEN NO WAVEY LINE
12000 RJE=.8
12100 RF=RJF
12200 JBX=JB
12300 RJF=495129.27
12400 C %@tr LWR CASE, ITAL. TR
12500 RJG=999999.99
12600 RJH=RJG
12700 JTR=JG
12800 GO TO 54
13000 52 IF(JTR.NE.0)RETURN
13200 C RETURN IF NO WAVY LINE IS NEEDED
13210 JB=JBX+27.*RSTJC
13300 JA=4
13400 RJB=RTR+4.*RSTJC
13500 JG=-2
13600 C JG IS SWITCH TO DRAW WIGGLE
13650 RJF=RF
13700 RJE=RJD+.8
13710 RJH=0
13800 CALL ITMSUB
13900 END